home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / src / tclExpr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-02  |  53.7 KB  |  2,014 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCL_EXPR
  3. #endif
  4.  
  5. /* 
  6.  * tclExpr.c --
  7.  *
  8.  *    This file contains the code to evaluate expressions for
  9.  *    Tcl.
  10.  *
  11.  *    This implementation of floating-point support was modelled
  12.  *    after an initial implementation by Bill Carpenter.
  13.  *
  14.  * Copyright (c) 1987-1993 The Regents of the University of California.
  15.  * All rights reserved.
  16.  *
  17.  * Permission is hereby granted, without written agreement and without
  18.  * license or royalty fees, to use, copy, modify, and distribute this
  19.  * software and its documentation for any purpose, provided that the
  20.  * above copyright notice and the following two paragraphs appear in
  21.  * all copies of this software.
  22.  * 
  23.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  24.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  25.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  26.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27.  *
  28.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  29.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  30.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  31.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  32.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  33.  */
  34.  
  35. #ifndef lint
  36. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclExpr.c,v 1.66 93/08/28 16:34:49 ouster Exp $ SPRITE (Berkeley)";
  37. #endif
  38.  
  39. #include "tclInt.h"
  40. #ifdef NO_FLOAT_H
  41. #   include "compat/float.h"
  42. #else
  43. #   include <float.h>
  44. #endif
  45. #ifndef TCL_NO_MATH
  46. #include <math.h>
  47. #endif
  48.  
  49. /*
  50.  * The stuff below is a bit of a hack so that this file can be used
  51.  * in environments that include no UNIX, i.e. no errno.  Just define
  52.  * errno here.
  53.  */
  54.  
  55. #ifndef TCL_GENERIC_ONLY
  56. #include "tclUnix.h"
  57. extern int errno;
  58. #endif
  59.  
  60. #ifdef NO_ERRNO_H
  61. int errno;
  62. #define EDOM 33
  63. #define ERANGE 34
  64. #endif
  65.  
  66. /*
  67.  * The data structure below is used to describe an expression value,
  68.  * which can be either an integer (the usual case), a double-precision
  69.  * floating-point value, or a string.  A given number has only one
  70.  * value at a time.
  71.  */
  72.  
  73. #define STATIC_STRING_SPACE 150
  74.  
  75. typedef struct {
  76.     long intValue;        /* Integer value, if any. */
  77.     double  doubleValue;    /* Floating-point value, if any. */
  78.     ParseValue pv;        /* Used to hold a string value, if any. */
  79.     char staticSpace[STATIC_STRING_SPACE];
  80.                 /* Storage for small strings;  large ones
  81.                  * are malloc-ed. */
  82.     int type;            /* Type of value:  TYPE_INT, TYPE_DOUBLE,
  83.                  * or TYPE_STRING. */
  84. } Value;
  85.  
  86. /*
  87.  * Valid values for type:
  88.  */
  89.  
  90. #define TYPE_INT    0
  91. #define TYPE_DOUBLE    1
  92. #define TYPE_STRING    2
  93.  
  94. /*
  95.  * The data structure below describes the state of parsing an expression.
  96.  * It's passed among the routines in this module.
  97.  */
  98.  
  99. typedef struct {
  100.     char *originalExpr;        /* The entire expression, as originally
  101.                  * passed to Tcl_ExprString et al. */
  102.     char *expr;            /* Position to the next character to be
  103.                  * scanned from the expression string. */
  104.     int token;            /* Type of the last token to be parsed from
  105.                  * expr.  See below for definitions.
  106.                  * Corresponds to the characters just
  107.                  * before expr. */
  108. } ExprInfo;
  109.  
  110. /*
  111.  * The token types are defined below.  In addition, there is a table
  112.  * associating a precedence with each operator.  The order of types
  113.  * is important.  Consult the code before changing it.
  114.  */
  115.  
  116. #define VALUE        0
  117. #define OPEN_PAREN    1
  118. #define CLOSE_PAREN    2
  119. #define COMMA        3
  120. #define END        4
  121. #define UNKNOWN        5
  122.  
  123. /*
  124.  * Binary operators:
  125.  */
  126.  
  127. #define MULT        8
  128. #define DIVIDE        9
  129. #define MOD        10
  130. #define PLUS        11
  131. #define MINUS        12
  132. #define LEFT_SHIFT    13
  133. #define RIGHT_SHIFT    14
  134. #define LESS        15
  135. #define GREATER        16
  136. #define LEQ        17
  137. #define GEQ        18
  138. #define EQUAL        19
  139. #define NEQ        20
  140. #define BIT_AND        21
  141. #define BIT_XOR        22
  142. #define BIT_OR        23
  143. #define AND        24
  144. #define OR        25
  145. #define QUESTY        26
  146. #define COLON        27
  147.  
  148. /*
  149.  * Unary operators:
  150.  */
  151.  
  152. #define    UNARY_MINUS    28
  153. #define NOT        29
  154. #define BIT_NOT        30
  155.  
  156. /*
  157.  * Precedence table.  The values for non-operator token types are ignored.
  158.  */
  159.  
  160. int precTable[] = {
  161.     0, 0, 0, 0, 0, 0, 0, 0,
  162.     11, 11, 11,                /* MULT, DIVIDE, MOD */
  163.     10, 10,                /* PLUS, MINUS */
  164.     9, 9,                /* LEFT_SHIFT, RIGHT_SHIFT */
  165.     8, 8, 8, 8,                /* LESS, GREATER, LEQ, GEQ */
  166.     7, 7,                /* EQUAL, NEQ */
  167.     6,                    /* BIT_AND */
  168.     5,                    /* BIT_XOR */
  169.     4,                    /* BIT_OR */
  170.     3,                    /* AND */
  171.     2,                    /* OR */
  172.     1, 1,                /* QUESTY, COLON */
  173.     12, 12, 12                /* UNARY_MINUS, NOT, BIT_NOT */
  174. };
  175.  
  176. /*
  177.  * Mapping from operator numbers to strings;  used for error messages.
  178.  */
  179.  
  180. char *operatorStrings[] = {
  181.     "VALUE", "(", ")", "END", "UNKNOWN", "5", "6", "7",
  182.     "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=",
  183.     ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":",
  184.     "-", "!", "~"
  185. };
  186.  
  187. /*
  188.  * The following slight modification to DBL_MAX is needed because of
  189.  * a compiler bug on Sprite (4/15/93).
  190.  */
  191.  
  192. #ifdef sprite
  193. #undef DBL_MAX
  194. #define DBL_MAX 1.797693134862316e+307
  195. #endif
  196.  
  197. /*
  198.  * Macros for testing floating-point values for certain special
  199.  * cases.  Test for not-a-number by comparing a value against
  200.  * itself;  test for infinity by comparing against the largest
  201.  * floating-point value.
  202.  */
  203.  
  204. #define IS_NAN(v) ((v) != (v))
  205. #ifdef DBL_MAX
  206. #   define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
  207. #else
  208. #   define IS_INF(v) 0
  209. #endif
  210.  
  211. /*
  212.  * The following global variable is use to signal matherr that Tcl
  213.  * is responsible for the arithmetic, so errors can be handled in a
  214.  * fashion appropriate for Tcl.  Zero means no Tcl math is in
  215.  * progress;  non-zero means Tcl is doing math.
  216.  */
  217.  
  218. int tcl_MathInProgress = 0;
  219.  
  220. /*
  221.  * The variable below serves no useful purpose except to generate
  222.  * a reference to matherr, so that the Tcl version of matherr is
  223.  * linked in rather than the system version.  Without this reference
  224.  * the need for matherr won't be discovered during linking until after
  225.  * libtcl.a has been processed, so Tcl's version won't be used.
  226.  */
  227.  
  228. #ifdef NEED_MATHERR
  229. extern int matherr();
  230. int (*tclMatherrPtr)() = matherr;
  231. #endif
  232.  
  233. /*
  234.  * Declarations for local procedures to this file:
  235.  */
  236.  
  237. static int        ExprAbsFunc _ANSI_ARGS_((ClientData clientData,
  238.                 Tcl_Interp *interp, Tcl_Value *args,
  239.                 Tcl_Value *resultPtr));
  240. static int        ExprBinaryFunc _ANSI_ARGS_((ClientData clientData,
  241.                 Tcl_Interp *interp, Tcl_Value *args,
  242.                 Tcl_Value *resultPtr));
  243. static int        ExprDoubleFunc _ANSI_ARGS_((ClientData clientData,
  244.                 Tcl_Interp *interp, Tcl_Value *args,
  245.                 Tcl_Value *resultPtr));
  246. static void        ExprFloatError _ANSI_ARGS_((Tcl_Interp *interp,
  247.                 double value));
  248. static int        ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp,
  249.                 ExprInfo *infoPtr, int prec, Value *valuePtr));
  250. static int        ExprIntFunc _ANSI_ARGS_((ClientData clientData,
  251.                 Tcl_Interp *interp, Tcl_Value *args,
  252.                 Tcl_Value *resultPtr));
  253. static int        ExprLex _ANSI_ARGS_((Tcl_Interp *interp,
  254.                 ExprInfo *infoPtr, Value *valuePtr));
  255. static void        ExprMakeString _ANSI_ARGS_((Tcl_Interp *interp,
  256.                 Value *valuePtr));
  257. static int        ExprMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
  258.                 ExprInfo *infoPtr, Value *valuePtr));
  259. static int        ExprParseString _ANSI_ARGS_((Tcl_Interp *interp,
  260.                 char *string, Value *valuePtr));
  261. static int        ExprRoundFunc _ANSI_ARGS_((ClientData clientData,
  262.                 Tcl_Interp *interp, Tcl_Value *args,
  263.                 Tcl_Value *resultPtr));
  264. static int        ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp,
  265.                 char *string, Value *valuePtr));
  266. static int        ExprUnaryFunc _ANSI_ARGS_((ClientData clientData,
  267.                 Tcl_Interp *interp, Tcl_Value *args,
  268.                 Tcl_Value *resultPtr));
  269.  
  270. /*
  271.  * Built-in math functions:
  272.  */
  273.  
  274. typedef struct {
  275.     char *name;            /* Name of function. */
  276.     int numArgs;        /* Number of arguments for function. */
  277.     Tcl_ValueType argTypes[MAX_MATH_ARGS];
  278.                 /* Acceptable types for each argument. */
  279.     Tcl_MathProc *proc;        /* Procedure that implements this function. */
  280.     ClientData clientData;    /* Additional argument to pass to the function
  281.                  * when invoking it. */
  282. } BuiltinFunc;
  283.  
  284. #ifdef THINK_C
  285.     extern double hypot();
  286. #endif
  287.  
  288. static BuiltinFunc funcTable[] = {
  289. #ifndef TCL_NO_MATH
  290.     {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
  291.     {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
  292.     {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
  293.     {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
  294.     {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
  295.     {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
  296.     {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
  297.     {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
  298.     {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
  299.     {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
  300.  
  301.     {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
  302.  
  303.     {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
  304.     {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
  305.     {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
  306.     {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
  307.     {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
  308.     {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
  309.     {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
  310.     {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
  311. #endif
  312.     {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
  313.     {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
  314.     {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
  315.     {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
  316.  
  317.     {0},
  318. };
  319.  
  320. /*
  321.  *--------------------------------------------------------------
  322.  *
  323.  * ExprParseString --
  324.  *
  325.  *    Given a string (such as one coming from command or variable
  326.  *    substitution), make a Value based on the string.  The value
  327.  *    will be a floating-point or integer, if possible, or else it
  328.  *    will just be a copy of the string.
  329.  *
  330.  * Results:
  331.  *    TCL_OK is returned under normal circumstances, and TCL_ERROR
  332.  *    is returned if a floating-point overflow or underflow occurred
  333.  *    while reading in a number.  The value at *valuePtr is modified
  334.  *    to hold a number, if possible.
  335.  *
  336.  * Side effects:
  337.  *    None.
  338.  *
  339.  *--------------------------------------------------------------
  340.  */
  341.  
  342. static int
  343. ExprParseString(interp, string, valuePtr)
  344.     Tcl_Interp *interp;        /* Where to store error message. */
  345.     char *string;        /* String to turn into value. */
  346.     Value *valuePtr;        /* Where to store value information. 
  347.                  * Caller must have initialized pv field. */
  348. {
  349.     char *term, *p, *start;
  350.  
  351.     if (*string != 0) {
  352.     valuePtr->type = TYPE_INT;
  353.     errno = 0;
  354.  
  355.     /*
  356.      * Note: use strtoul instead of strtol for integer conversions
  357.      * to allow full-size unsigned numbers, but don't depend on
  358.      * strtoul to handle sign characters;  it won't in some
  359.      * implementations.
  360.      */
  361.  
  362.     for (p = string; isspace(UCHAR(*p)); p++) {
  363.         /* Empty loop body. */
  364.     }
  365.     if (*p == '-') {
  366.         start = p+1;
  367.         valuePtr->intValue = -strtoul(start, &term, 0);
  368.     } else if (*p == '+') {
  369.         start = p+1;
  370.         valuePtr->intValue = strtoul(start, &term, 0);
  371.     } else {
  372.         start = p;
  373.         valuePtr->intValue = strtoul(start, &term, 0);
  374.     }
  375.     if (errno == ERANGE) {
  376.         /*
  377.          * This procedure is sometimes called with string in
  378.          * interp->result, so we have to clear the result before
  379.          * logging an error message.
  380.          */
  381.  
  382.         Tcl_ResetResult(interp);
  383.         interp->result = "integer value too large to represent";
  384.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result,
  385.             (char *) NULL);
  386.         return TCL_ERROR;
  387.     }
  388.     if ((term != start) && (*term == '\0')) {
  389.         return TCL_OK;
  390.     }
  391.     errno = 0;
  392.     valuePtr->doubleValue = strtod(p, &term);
  393.     if ((term != p) && (*term == '\0')) {
  394.         if (errno != 0) {
  395.         Tcl_ResetResult(interp);
  396.         ExprFloatError(interp, valuePtr->doubleValue);
  397.         return TCL_ERROR;
  398.         }
  399.         valuePtr->type = TYPE_DOUBLE;
  400.         return TCL_OK;
  401.     }
  402.     }
  403.  
  404.     /*
  405.      * Not a valid number.  Save a string value (but don't do anything
  406.      * if it's already the value).
  407.      */
  408.  
  409.     valuePtr->type = TYPE_STRING;
  410.     if (string != valuePtr->pv.buffer) {
  411.     int length, shortfall;
  412.  
  413.     length = strlen(string);
  414.     valuePtr->pv.next = valuePtr->pv.buffer;
  415.     shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer);
  416.     if (shortfall > 0) {
  417.         (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
  418.     }
  419.     strcpy(valuePtr->pv.buffer, string);
  420.     }
  421.     return TCL_OK;
  422. }
  423.  
  424. /*
  425.  *----------------------------------------------------------------------
  426.  *
  427.  * ExprLex --
  428.  *
  429.  *    Lexical analyzer for expression parser:  parses a single value,
  430.  *    operator, or other syntactic element from an expression string.
  431.  *
  432.  * Results:
  433.  *    TCL_OK is returned unless an error occurred while doing lexical
  434.  *    analysis or executing an embedded command.  In that case a
  435.  *    standard Tcl error is returned, using interp->result to hold
  436.  *    an error message.  In the event of a successful return, the token
  437.  *    and field in infoPtr is updated to refer to the next symbol in
  438.  *    the expression string, and the expr field is advanced past that
  439.  *    token;  if the token is a value, then the value is stored at
  440.  *    valuePtr.
  441.  *
  442.  * Side effects:
  443.  *    None.
  444.  *
  445.  *----------------------------------------------------------------------
  446.  */
  447.  
  448. static int
  449. ExprLex(interp, infoPtr, valuePtr)
  450.     Tcl_Interp *interp;            /* Interpreter to use for error
  451.                      * reporting. */
  452.     register ExprInfo *infoPtr;        /* Describes the state of the parse. */
  453.     register Value *valuePtr;        /* Where to store value, if that is
  454.                      * what's parsed from string.  Caller
  455.                      * must have initialized pv field
  456.                      * correctly. */
  457. {
  458.     register char *p;
  459.     char *var, *term;
  460.     int result;
  461.  
  462.     p = infoPtr->expr;
  463.     while (isspace(UCHAR(*p))) {
  464.     p++;
  465.     }
  466.     if (*p == 0) {
  467.     infoPtr->token = END;
  468.     infoPtr->expr = p;
  469.     return TCL_OK;
  470.     }
  471.  
  472.     /*
  473.      * First try to parse the token as an integer or floating-point number.
  474.      * A couple of tricky points:
  475.      *
  476.      * 1. Can't just check for leading digits to see if there's a number
  477.      *    there, because it could be a special value like "NaN".
  478.      * 2. Don't want to check for a number if the first character is "+"
  479.      *    or "-".  If we do, we might treat a binary operator as unary
  480.      *    by mistake, which will eventually cause a syntax error.
  481.      * 3. First see if there's an integer, then if there's stuff after
  482.      *    the integer that looks like it could be a floating-point number
  483.      *    (or if there wasn't even a sensible integer), then try to parse
  484.      *    as a floating-point number.  The check for the characters '8'
  485.      *      or '9' is to handle floating-point numbers like 028.6:  the
  486.      *    leading zero causes strtoul to interpret the number as octal
  487.      *    and stop when it gets to the 8.
  488.      */
  489.  
  490.     if ((*p != '+')  && (*p != '-')) {
  491.     errno = 0;
  492.     valuePtr->intValue = strtoul(p, &term, 0);
  493.     if ((term == p) || (*term == '.') || (*term == 'e') ||
  494.         (*term == 'E') || (*term == '8') || (*term == '9')) {
  495.         char *term2;
  496.     
  497.         /*
  498.          * The code here is a bit tricky:  we want to use a floating-point
  499.          * number if there is one, but if there isn't then fall through to
  500.          * use the integer that was already parsed, if there was one.
  501.          */
  502.     
  503.         errno = 0;
  504.         valuePtr->doubleValue = strtod(p, &term2);
  505.         if (term2 != p) {
  506.         if (errno != 0) {
  507.             ExprFloatError(interp, valuePtr->doubleValue);
  508.             return TCL_ERROR;
  509.         }
  510.         infoPtr->token = VALUE;
  511.         infoPtr->expr = term2;
  512.         valuePtr->type = TYPE_DOUBLE;
  513.         return TCL_OK;
  514.         }
  515.         if (term != p) {
  516.         interp->result = "poorly-formed floating-point value";
  517.         return TCL_ERROR;
  518.         }
  519.     }
  520.     if (term != p) {
  521.         /*
  522.          * No floating-point number, but there is an integer.
  523.          */
  524.     
  525.         if (errno == ERANGE) {
  526.         interp->result = "integer value too large to represent";
  527.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result,
  528.             (char *) NULL);
  529.         return TCL_ERROR;
  530.         }
  531.         infoPtr->token = VALUE;
  532.         infoPtr->expr = term;
  533.         valuePtr->type = TYPE_INT;
  534.         return TCL_OK;
  535.     }
  536.     }
  537.  
  538.     infoPtr->expr = p+1;
  539.     switch (*p) {
  540.     case '$':
  541.  
  542.         /*
  543.          * Variable.  Fetch its value, then see if it makes sense
  544.          * as an integer or floating-point number.
  545.          */
  546.  
  547.         infoPtr->token = VALUE;
  548.         var = Tcl_ParseVar(interp, p, &infoPtr->expr);
  549.         if (var == NULL) {
  550.         return TCL_ERROR;
  551.         }
  552.         Tcl_ResetResult(interp);
  553.         if (((Interp *) interp)->noEval) {
  554.         valuePtr->type = TYPE_INT;
  555.         valuePtr->intValue = 0;
  556.         return TCL_OK;
  557.         }
  558.         return ExprParseString(interp, var, valuePtr);
  559.  
  560.     case '[':
  561.         infoPtr->token = VALUE;
  562.         ((Interp *) interp)->evalFlags = TCL_BRACKET_TERM;
  563.         result = Tcl_Eval(interp, p+1);
  564.         infoPtr->expr = ((Interp *) interp)->termPtr;
  565.         if (result != TCL_OK) {
  566.         return result;
  567.         }
  568.         infoPtr->expr++;
  569.         if (((Interp *) interp)->noEval) {
  570.         valuePtr->type = TYPE_INT;
  571.         valuePtr->intValue = 0;
  572.         Tcl_ResetResult(interp);
  573.         return TCL_OK;
  574.         }
  575.         result = ExprParseString(interp, interp->result, valuePtr);
  576.         if (result != TCL_OK) {
  577.         return result;
  578.         }
  579.         Tcl_ResetResult(interp);
  580.         return TCL_OK;
  581.  
  582.     case '"':
  583.         infoPtr->token = VALUE;
  584.         result = TclParseQuotes(interp, infoPtr->expr, '"', 0,
  585.             &infoPtr->expr, &valuePtr->pv);
  586.         if (result != TCL_OK) {
  587.         return result;
  588.         }
  589.         Tcl_ResetResult(interp);
  590.         return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
  591.  
  592.     case '{':
  593.         infoPtr->token = VALUE;
  594.         result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr,
  595.             &valuePtr->pv);
  596.         if (result != TCL_OK) {
  597.         return result;
  598.         }
  599.         Tcl_ResetResult(interp);
  600.         return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
  601.  
  602.     case '(':
  603.         infoPtr->token = OPEN_PAREN;
  604.         return TCL_OK;
  605.  
  606.     case ')':
  607.         infoPtr->token = CLOSE_PAREN;
  608.         return TCL_OK;
  609.  
  610.     case ',':
  611.         infoPtr->token = COMMA;
  612.         return TCL_OK;
  613.  
  614.     case '*':
  615.         infoPtr->token = MULT;
  616.         return TCL_OK;
  617.  
  618.     case '/':
  619.         infoPtr->token = DIVIDE;
  620.         return TCL_OK;
  621.  
  622.     case '%':
  623.         infoPtr->token = MOD;
  624.         return TCL_OK;
  625.  
  626.     case '+':
  627.         infoPtr->token = PLUS;
  628.         return TCL_OK;
  629.  
  630.     case '-':
  631.         infoPtr->token = MINUS;
  632.         return TCL_OK;
  633.  
  634.     case '?':
  635.         infoPtr->token = QUESTY;
  636.         return TCL_OK;
  637.  
  638.     case ':':
  639.         infoPtr->token = COLON;
  640.         return TCL_OK;
  641.  
  642.     case '<':
  643.         switch (p[1]) {
  644.         case '<':
  645.             infoPtr->expr = p+2;
  646.             infoPtr->token = LEFT_SHIFT;
  647.             break;
  648.         case '=':
  649.             infoPtr->expr = p+2;
  650.             infoPtr->token = LEQ;
  651.             break;
  652.         default:
  653.             infoPtr->token = LESS;
  654.             break;
  655.         }
  656.         return TCL_OK;
  657.  
  658.     case '>':
  659.         switch (p[1]) {
  660.         case '>':
  661.             infoPtr->expr = p+2;
  662.             infoPtr->token = RIGHT_SHIFT;
  663.             break;
  664.         case '=':
  665.             infoPtr->expr = p+2;
  666.             infoPtr->token = GEQ;
  667.             break;
  668.         default:
  669.             infoPtr->token = GREATER;
  670.             break;
  671.         }
  672.         return TCL_OK;
  673.  
  674.     case '=':
  675.         if (p[1] == '=') {
  676.         infoPtr->expr = p+2;
  677.         infoPtr->token = EQUAL;
  678.         } else {
  679.         infoPtr->token = UNKNOWN;
  680.         }
  681.         return TCL_OK;
  682.  
  683.     case '!':
  684.         if (p[1] == '=') {
  685.         infoPtr->expr = p+2;
  686.         infoPtr->token = NEQ;
  687.         } else {
  688.         infoPtr->token = NOT;
  689.         }
  690.         return TCL_OK;
  691.  
  692.     case '&':
  693.         if (p[1] == '&') {
  694.         infoPtr->expr = p+2;
  695.         infoPtr->token = AND;
  696.         } else {
  697.         infoPtr->token = BIT_AND;
  698.         }
  699.         return TCL_OK;
  700.  
  701.     case '^':
  702.         infoPtr->token = BIT_XOR;
  703.         return TCL_OK;
  704.  
  705.     case '|':
  706.         if (p[1] == '|') {
  707.         infoPtr->expr = p+2;
  708.         infoPtr->token = OR;
  709.         } else {
  710.         infoPtr->token = BIT_OR;
  711.         }
  712.         return TCL_OK;
  713.  
  714.     case '~':
  715.         infoPtr->token = BIT_NOT;
  716.         return TCL_OK;
  717.  
  718.     default:
  719.         if (isalpha(UCHAR(*p))) {
  720.         infoPtr->expr = p;
  721.         return ExprMathFunc(interp, infoPtr, valuePtr);
  722.         }
  723.         infoPtr->expr = p+1;
  724.         infoPtr->token = UNKNOWN;
  725.         return TCL_OK;
  726.     }
  727. }
  728.  
  729. /*
  730.  *----------------------------------------------------------------------
  731.  *
  732.  * ExprGetValue --
  733.  *
  734.  *    Parse a "value" from the remainder of the expression in infoPtr.
  735.  *
  736.  * Results:
  737.  *    Normally TCL_OK is returned.  The value of the expression is
  738.  *    returned in *valuePtr.  If an error occurred, then interp->result
  739.  *    contains an error message and TCL_ERROR is returned.
  740.  *    InfoPtr->token will be left pointing to the token AFTER the
  741.  *    expression, and infoPtr->expr will point to the character just
  742.  *    after the terminating token.
  743.  *
  744.  * Side effects:
  745.  *    None.
  746.  *
  747.  *----------------------------------------------------------------------
  748.  */
  749.  
  750. static int
  751. ExprGetValue(interp, infoPtr, prec, valuePtr)
  752.     Tcl_Interp *interp;            /* Interpreter to use for error
  753.                      * reporting. */
  754.     register ExprInfo *infoPtr;        /* Describes the state of the parse
  755.                      * just before the value (i.e. ExprLex
  756.                      * will be called to get first token
  757.                      * of value). */
  758.     int prec;                /* Treat any un-parenthesized operator
  759.                      * with precedence <= this as the end
  760.                      * of the expression. */
  761.     Value *valuePtr;            /* Where to store the value of the
  762.                      * expression.   Caller must have
  763.                      * initialized pv field. */
  764. {
  765.     Interp *iPtr = (Interp *) interp;
  766.     Value value2;            /* Second operand for current
  767.                      * operator.  */
  768.     int operator;            /* Current operator (either unary
  769.                      * or binary). */
  770.     int badType;            /* Type of offending argument;  used
  771.                      * for error messages. */
  772.     int gotOp;                /* Non-zero means already lexed the
  773.                      * operator (while picking up value
  774.                      * for unary operator).  Don't lex
  775.                      * again. */
  776.     int result;
  777.  
  778.     /*
  779.      * There are two phases to this procedure.  First, pick off an initial
  780.      * value.  Then, parse (binary operator, value) pairs until done.
  781.      */
  782.  
  783.     gotOp = 0;
  784.     value2.pv.buffer = value2.pv.next = value2.staticSpace;
  785.     value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1;
  786.     value2.pv.expandProc = TclExpandParseValue;
  787.     value2.pv.clientData = (ClientData) NULL;
  788.     result = ExprLex(interp, infoPtr, valuePtr);
  789.     if (result != TCL_OK) {
  790.     goto done;
  791.     }
  792.     if (infoPtr->token == OPEN_PAREN) {
  793.  
  794.     /*
  795.      * Parenthesized sub-expression.
  796.      */
  797.  
  798.     result = ExprGetValue(interp, infoPtr, -1, valuePtr);
  799.     if (result != TCL_OK) {
  800.         goto done;
  801.     }
  802.     if (infoPtr->token != CLOSE_PAREN) {
  803.         Tcl_AppendResult(interp, "unmatched parentheses in expression \"",
  804.             infoPtr->originalExpr, "\"", (char *) NULL);
  805.         result = TCL_ERROR;
  806.         goto done;
  807.     }
  808.     } else {
  809.     if (infoPtr->token == MINUS) {
  810.         infoPtr->token = UNARY_MINUS;
  811.     }
  812.     if (infoPtr->token >= UNARY_MINUS) {
  813.  
  814.         /*
  815.          * Process unary operators.
  816.          */
  817.  
  818.         operator = infoPtr->token;
  819.         result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token],
  820.             valuePtr);
  821.         if (result != TCL_OK) {
  822.         goto done;
  823.         }
  824.         switch (operator) {
  825.         case UNARY_MINUS:
  826.             if (valuePtr->type == TYPE_INT) {
  827.             valuePtr->intValue = -valuePtr->intValue;
  828.             } else if (valuePtr->type == TYPE_DOUBLE){
  829.             valuePtr->doubleValue = -valuePtr->doubleValue;
  830.             } else {
  831.             badType = valuePtr->type;
  832.             goto illegalType;
  833.             } 
  834.             break;
  835.         case NOT:
  836.             if (valuePtr->type == TYPE_INT) {
  837.             valuePtr->intValue = !valuePtr->intValue;
  838.             } else if (valuePtr->type == TYPE_DOUBLE) {
  839.             /*
  840.              * Theoretically, should be able to use
  841.              * "!valuePtr->intValue", but apparently some
  842.              * compilers can't handle it.
  843.              */
  844.             if (valuePtr->doubleValue == 0.0) {
  845.                 valuePtr->intValue = 1;
  846.             } else {
  847.                 valuePtr->intValue = 0;
  848.             }
  849.             valuePtr->type = TYPE_INT;
  850.             } else {
  851.             badType = valuePtr->type;
  852.             goto illegalType;
  853.             }
  854.             break;
  855.         case BIT_NOT:
  856.             if (valuePtr->type == TYPE_INT) {
  857.             valuePtr->intValue = ~valuePtr->intValue;
  858.             } else {
  859.             badType  = valuePtr->type;
  860.             goto illegalType;
  861.             }
  862.             break;
  863.         }
  864.         gotOp = 1;
  865.     } else if (infoPtr->token != VALUE) {
  866.         goto syntaxError;
  867.     }
  868.     }
  869.  
  870.     /*
  871.      * Got the first operand.  Now fetch (operator, operand) pairs.
  872.      */
  873.  
  874.     if (!gotOp) {
  875.     result = ExprLex(interp, infoPtr, &value2);
  876.     if (result != TCL_OK) {
  877.         goto done;
  878.     }
  879.     }
  880.     while (1) {
  881.     operator = infoPtr->token;
  882.     value2.pv.next = value2.pv.buffer;
  883.     if ((operator < MULT) || (operator >= UNARY_MINUS)) {
  884.         if ((operator == END) || (operator == CLOSE_PAREN)
  885.             || (operator == COMMA)) {
  886.         result = TCL_OK;
  887.         goto done;
  888.         } else {
  889.         goto syntaxError;
  890.         }
  891.     }
  892.     if (precTable[operator] <= prec) {
  893.         result = TCL_OK;
  894.         goto done;
  895.     }
  896.  
  897.     /*
  898.      * If we're doing an AND or OR and the first operand already
  899.      * determines the result, don't execute anything in the
  900.      * second operand:  just parse.  Same style for ?: pairs.
  901.      */
  902.  
  903.     if ((operator == AND) || (operator == OR) || (operator == QUESTY)) {
  904.         if (valuePtr->type == TYPE_DOUBLE) {
  905.         valuePtr->intValue = valuePtr->doubleValue != 0;
  906.         valuePtr->type = TYPE_INT;
  907.         } else if (valuePtr->type == TYPE_STRING) {
  908.         badType = TYPE_STRING;
  909.         goto illegalType;
  910.         }
  911.         if (((operator == AND) && !valuePtr->intValue)
  912.             || ((operator == OR) && valuePtr->intValue)) {
  913.         iPtr->noEval++;
  914.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  915.             &value2);
  916.         iPtr->noEval--;
  917.         } else if (operator == QUESTY) {
  918.         if (valuePtr->intValue != 0) {
  919.             valuePtr->pv.next = valuePtr->pv.buffer;
  920.             result = ExprGetValue(interp, infoPtr, precTable[operator],
  921.                 valuePtr);
  922.             if (result != TCL_OK) {
  923.             goto done;
  924.             }
  925.             if (infoPtr->token != COLON) {
  926.             goto syntaxError;
  927.             }
  928.             value2.pv.next = value2.pv.buffer;
  929.             iPtr->noEval++;
  930.             result = ExprGetValue(interp, infoPtr, precTable[operator],
  931.                 &value2);
  932.             iPtr->noEval--;
  933.         } else {
  934.             iPtr->noEval++;
  935.             result = ExprGetValue(interp, infoPtr, precTable[operator],
  936.                 &value2);
  937.             iPtr->noEval--;
  938.             if (result != TCL_OK) {
  939.             goto done;
  940.             }
  941.             if (infoPtr->token != COLON) {
  942.             goto syntaxError;
  943.             }
  944.             valuePtr->pv.next = valuePtr->pv.buffer;
  945.             result = ExprGetValue(interp, infoPtr, precTable[operator],
  946.                 valuePtr);
  947.         }
  948.         } else {
  949.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  950.             &value2);
  951.         }
  952.     } else {
  953.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  954.             &value2);
  955.     }
  956.     if (result != TCL_OK) {
  957.         goto done;
  958.     }
  959.     if ((infoPtr->token < MULT) && (infoPtr->token != VALUE)
  960.         && (infoPtr->token != END) && (infoPtr->token != COMMA)
  961.         && (infoPtr->token != CLOSE_PAREN)) {
  962.         goto syntaxError;
  963.     }
  964.  
  965.     /*
  966.      * At this point we've got two values and an operator.  Check
  967.      * to make sure that the particular data types are appropriate
  968.      * for the particular operator, and perform type conversion
  969.      * if necessary.
  970.      */
  971.  
  972.     switch (operator) {
  973.  
  974.         /*
  975.          * For the operators below, no strings are allowed and
  976.          * ints get converted to floats if necessary.
  977.          */
  978.  
  979.         case MULT: case DIVIDE: case PLUS: case MINUS:
  980.         if ((valuePtr->type == TYPE_STRING)
  981.             || (value2.type == TYPE_STRING)) {
  982.             badType = TYPE_STRING;
  983.             goto illegalType;
  984.         }
  985.         if (valuePtr->type == TYPE_DOUBLE) {
  986.             if (value2.type == TYPE_INT) {
  987.             value2.doubleValue = value2.intValue;
  988.             value2.type = TYPE_DOUBLE;
  989.             }
  990.         } else if (value2.type == TYPE_DOUBLE) {
  991.             if (valuePtr->type == TYPE_INT) {
  992.             valuePtr->doubleValue = valuePtr->intValue;
  993.             valuePtr->type = TYPE_DOUBLE;
  994.             }
  995.         }
  996.         break;
  997.  
  998.         /*
  999.          * For the operators below, only integers are allowed.
  1000.          */
  1001.  
  1002.         case MOD: case LEFT_SHIFT: case RIGHT_SHIFT:
  1003.         case BIT_AND: case BIT_XOR: case BIT_OR:
  1004.          if (valuePtr->type != TYPE_INT) {
  1005.              badType = valuePtr->type;
  1006.              goto illegalType;
  1007.          } else if (value2.type != TYPE_INT) {
  1008.              badType = value2.type;
  1009.              goto illegalType;
  1010.          }
  1011.          break;
  1012.  
  1013.         /*
  1014.          * For the operators below, any type is allowed but the
  1015.          * two operands must have the same type.  Convert integers
  1016.          * to floats and either to strings, if necessary.
  1017.          */
  1018.  
  1019.         case LESS: case GREATER: case LEQ: case GEQ:
  1020.         case EQUAL: case NEQ:
  1021.         if (valuePtr->type == TYPE_STRING) {
  1022.             if (value2.type != TYPE_STRING) {
  1023.             ExprMakeString(interp, &value2);
  1024.             }
  1025.         } else if (value2.type == TYPE_STRING) {
  1026.             if (valuePtr->type != TYPE_STRING) {
  1027.             ExprMakeString(interp, valuePtr);
  1028.             }
  1029.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1030.             if (value2.type == TYPE_INT) {
  1031.             value2.doubleValue = value2.intValue;
  1032.             value2.type = TYPE_DOUBLE;
  1033.             }
  1034.         } else if (value2.type == TYPE_DOUBLE) {
  1035.              if (valuePtr->type == TYPE_INT) {
  1036.             valuePtr->doubleValue = valuePtr->intValue;
  1037.             valuePtr->type = TYPE_DOUBLE;
  1038.             }
  1039.         }
  1040.         break;
  1041.  
  1042.         /*
  1043.          * For the operators below, no strings are allowed, but
  1044.          * no int->double conversions are performed.
  1045.          */
  1046.  
  1047.         case AND: case OR:
  1048.         if (valuePtr->type == TYPE_STRING) {
  1049.             badType = valuePtr->type;
  1050.             goto illegalType;
  1051.         }
  1052.         if (value2.type == TYPE_STRING) {
  1053.             badType = value2.type;
  1054.             goto illegalType;
  1055.         }
  1056.         break;
  1057.  
  1058.         /*
  1059.          * For the operators below, type and conversions are
  1060.          * irrelevant:  they're handled elsewhere.
  1061.          */
  1062.  
  1063.         case QUESTY: case COLON:
  1064.         break;
  1065.  
  1066.         /*
  1067.          * Any other operator is an error.
  1068.          */
  1069.  
  1070.         default:
  1071.         interp->result = "unknown operator in expression";
  1072.         result = TCL_ERROR;
  1073.         goto done;
  1074.     }
  1075.  
  1076.     /*
  1077.      * If necessary, convert one of the operands to the type
  1078.      * of the other.  If the operands are incompatible with
  1079.      * the operator (e.g. "+" on strings) then return an
  1080.      * error.
  1081.      */
  1082.  
  1083.     switch (operator) {
  1084.         case MULT:
  1085.         if (valuePtr->type == TYPE_INT) {
  1086.             valuePtr->intValue *= value2.intValue;
  1087.         } else {
  1088.             valuePtr->doubleValue *= value2.doubleValue;
  1089.         }
  1090.         break;
  1091.         case DIVIDE:
  1092.         case MOD:
  1093.         if (valuePtr->type == TYPE_INT) {
  1094.             int divisor, quot, rem, negative;
  1095.             if (value2.intValue == 0) {
  1096.             divideByZero:
  1097.             interp->result = "divide by zero";
  1098.             Tcl_SetErrorCode(interp, "ARITH", "DIVZERO",
  1099.                 interp->result, (char *) NULL);
  1100.             result = TCL_ERROR;
  1101.             goto done;
  1102.             }
  1103.  
  1104.             /*
  1105.              * The code below is tricky because C doesn't guarantee
  1106.              * much about the properties of the quotient or
  1107.              * remainder, but Tcl does:  the remainder always has
  1108.              * the same sign as the divisor and a smaller absolute
  1109.              * value.
  1110.              */
  1111.  
  1112.             divisor = value2.intValue;
  1113.             negative = 0;
  1114.             if (divisor < 0) {
  1115.             divisor = -divisor;
  1116.             valuePtr->intValue = -valuePtr->intValue;
  1117.             negative = 1;
  1118.             }
  1119.             quot = valuePtr->intValue / divisor;
  1120.             rem = valuePtr->intValue % divisor;
  1121.             if (rem < 0) {
  1122.             rem += divisor;
  1123.             quot -= 1;
  1124.             }
  1125.             if (negative) {
  1126.             rem = -rem;
  1127.             }
  1128.             valuePtr->intValue = (operator == DIVIDE) ? quot : rem;
  1129.         } else {
  1130.             if (value2.doubleValue == 0.0) {
  1131.             goto divideByZero;
  1132.             }
  1133.             valuePtr->doubleValue /= value2.doubleValue;
  1134.         }
  1135.         break;
  1136.         case PLUS:
  1137.         if (valuePtr->type == TYPE_INT) {
  1138.             valuePtr->intValue += value2.intValue;
  1139.         } else {
  1140.             valuePtr->doubleValue += value2.doubleValue;
  1141.         }
  1142.         break;
  1143.         case MINUS:
  1144.         if (valuePtr->type == TYPE_INT) {
  1145.             valuePtr->intValue -= value2.intValue;
  1146.         } else {
  1147.             valuePtr->doubleValue -= value2.doubleValue;
  1148.         }
  1149.         break;
  1150.         case LEFT_SHIFT:
  1151.         valuePtr->intValue <<= value2.intValue;
  1152.         break;
  1153.         case RIGHT_SHIFT:
  1154.         /*
  1155.          * The following code is a bit tricky:  it ensures that
  1156.          * right shifts propagate the sign bit even on machines
  1157.          * where ">>" won't do it by default.
  1158.          */
  1159.  
  1160.         if (valuePtr->intValue < 0) {
  1161.             valuePtr->intValue =
  1162.                 ~((~valuePtr->intValue) >> value2.intValue);
  1163.         } else {
  1164.             valuePtr->intValue >>= value2.intValue;
  1165.         }
  1166.         break;
  1167.         case LESS:
  1168.         if (valuePtr->type == TYPE_INT) {
  1169.             valuePtr->intValue =
  1170.             valuePtr->intValue < value2.intValue;
  1171.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1172.             valuePtr->intValue =
  1173.             valuePtr->doubleValue < value2.doubleValue;
  1174.         } else {
  1175.             valuePtr->intValue =
  1176.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0;
  1177.         }
  1178.         valuePtr->type = TYPE_INT;
  1179.         break;
  1180.         case GREATER:
  1181.         if (valuePtr->type == TYPE_INT) {
  1182.             valuePtr->intValue =
  1183.             valuePtr->intValue > value2.intValue;
  1184.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1185.             valuePtr->intValue =
  1186.             valuePtr->doubleValue > value2.doubleValue;
  1187.         } else {
  1188.             valuePtr->intValue =
  1189.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0;
  1190.         }
  1191.         valuePtr->type = TYPE_INT;
  1192.         break;
  1193.         case LEQ:
  1194.         if (valuePtr->type == TYPE_INT) {
  1195.             valuePtr->intValue =
  1196.             valuePtr->intValue <= value2.intValue;
  1197.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1198.             valuePtr->intValue =
  1199.             valuePtr->doubleValue <= value2.doubleValue;
  1200.         } else {
  1201.             valuePtr->intValue =
  1202.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0;
  1203.         }
  1204.         valuePtr->type = TYPE_INT;
  1205.         break;
  1206.         case GEQ:
  1207.         if (valuePtr->type == TYPE_INT) {
  1208.             valuePtr->intValue =
  1209.             valuePtr->intValue >= value2.intValue;
  1210.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1211.             valuePtr->intValue =
  1212.             valuePtr->doubleValue >= value2.doubleValue;
  1213.         } else {
  1214.             valuePtr->intValue =
  1215.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0;
  1216.         }
  1217.         valuePtr->type = TYPE_INT;
  1218.         break;
  1219.         case EQUAL:
  1220.         if (valuePtr->type == TYPE_INT) {
  1221.             valuePtr->intValue =
  1222.             valuePtr->intValue == value2.intValue;
  1223.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1224.             valuePtr->intValue =
  1225.             valuePtr->doubleValue == value2.doubleValue;
  1226.         } else {
  1227.             valuePtr->intValue =
  1228.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0;
  1229.         }
  1230.         valuePtr->type = TYPE_INT;
  1231.         break;
  1232.         case NEQ:
  1233.         if (valuePtr->type == TYPE_INT) {
  1234.             valuePtr->intValue =
  1235.             valuePtr->intValue != value2.intValue;
  1236.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1237.             valuePtr->intValue =
  1238.             valuePtr->doubleValue != value2.doubleValue;
  1239.         } else {
  1240.             valuePtr->intValue =
  1241.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0;
  1242.         }
  1243.         valuePtr->type = TYPE_INT;
  1244.         break;
  1245.         case BIT_AND:
  1246.         valuePtr->intValue &= value2.intValue;
  1247.         break;
  1248.         case BIT_XOR:
  1249.         valuePtr->intValue ^= value2.intValue;
  1250.         break;
  1251.         case BIT_OR:
  1252.         valuePtr->intValue |= value2.intValue;
  1253.         break;
  1254.  
  1255.         /*
  1256.          * For AND and OR, we know that the first value has already
  1257.          * been converted to an integer.  Thus we need only consider
  1258.          * the possibility of int vs. double for the second value.
  1259.          */
  1260.  
  1261.         case AND:
  1262.         if (value2.type == TYPE_DOUBLE) {
  1263.             value2.intValue = value2.doubleValue != 0;
  1264.             value2.type = TYPE_INT;
  1265.         }
  1266.         valuePtr->intValue = valuePtr->intValue && value2.intValue;
  1267.         break;
  1268.         case OR:
  1269.         if (value2.type == TYPE_DOUBLE) {
  1270.             value2.intValue = value2.doubleValue != 0;
  1271.             value2.type = TYPE_INT;
  1272.         }
  1273.         valuePtr->intValue = valuePtr->intValue || value2.intValue;
  1274.         break;
  1275.  
  1276.         case COLON:
  1277.         interp->result = "can't have : operator without ? first";
  1278.         result = TCL_ERROR;
  1279.         goto done;
  1280.     }
  1281.     }
  1282.  
  1283.     done:
  1284.     if (value2.pv.buffer != value2.staticSpace) {
  1285.     ckfree(value2.pv.buffer);
  1286.     }
  1287.     return result;
  1288.  
  1289.     syntaxError:
  1290.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1291.         infoPtr->originalExpr, "\"", (char *) NULL);
  1292.     result = TCL_ERROR;
  1293.     goto done;
  1294.  
  1295.     illegalType:
  1296.     Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ?
  1297.         "floating-point value" : "non-numeric string",
  1298.         " as operand of \"", operatorStrings[operator], "\"",
  1299.         (char *) NULL);
  1300.     result = TCL_ERROR;
  1301.     goto done;
  1302. }
  1303.  
  1304. /*
  1305.  *--------------------------------------------------------------
  1306.  *
  1307.  * ExprMakeString --
  1308.  *
  1309.  *    Convert a value from int or double representation to
  1310.  *    a string.
  1311.  *
  1312.  * Results:
  1313.  *    The information at *valuePtr gets converted to string
  1314.  *    format, if it wasn't that way already.
  1315.  *
  1316.  * Side effects:
  1317.  *    None.
  1318.  *
  1319.  *--------------------------------------------------------------
  1320.  */
  1321.  
  1322. static void
  1323. ExprMakeString(interp, valuePtr)
  1324.     Tcl_Interp *interp;            /* Interpreter to use for precision
  1325.                      * information. */
  1326.     register Value *valuePtr;        /* Value to be converted. */
  1327. {
  1328.     int shortfall;
  1329.  
  1330.     shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer);
  1331.     if (shortfall > 0) {
  1332.     (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
  1333.     }
  1334.     if (valuePtr->type == TYPE_INT) {
  1335.     sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue);
  1336.     } else if (valuePtr->type == TYPE_DOUBLE) {
  1337.     Tcl_PrintDouble(interp, valuePtr->doubleValue, valuePtr->pv.buffer);
  1338.     }
  1339.     valuePtr->type = TYPE_STRING;
  1340. }
  1341.  
  1342. /*
  1343.  *--------------------------------------------------------------
  1344.  *
  1345.  * ExprTopLevel --
  1346.  *
  1347.  *    This procedure provides top-level functionality shared by
  1348.  *    procedures like Tcl_ExprInt, Tcl_ExprDouble, etc.
  1349.  *
  1350.  * Results:
  1351.  *    The result is a standard Tcl return value.  If an error
  1352.  *    occurs then an error message is left in interp->result.
  1353.  *    The value of the expression is returned in *valuePtr, in
  1354.  *    whatever form it ends up in (could be string or integer
  1355.  *    or double).  Caller may need to convert result.  Caller
  1356.  *    is also responsible for freeing string memory in *valuePtr,
  1357.  *    if any was allocated.
  1358.  *
  1359.  * Side effects:
  1360.  *    None.
  1361.  *
  1362.  *--------------------------------------------------------------
  1363.  */
  1364.  
  1365. static int
  1366. ExprTopLevel(interp, string, valuePtr)
  1367.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1368.                      * expression. */
  1369.     char *string;            /* Expression to evaluate. */
  1370.     Value *valuePtr;            /* Where to store result.  Should
  1371.                      * not be initialized by caller. */
  1372. {
  1373.     ExprInfo info;
  1374.     int result;
  1375.  
  1376.     /*
  1377.      * Create the math functions the first time an expression is
  1378.      * evaluated.
  1379.      */
  1380.  
  1381.     if (!(((Interp *) interp)->flags & EXPR_INITIALIZED)) {
  1382.     BuiltinFunc *funcPtr;
  1383.  
  1384.     ((Interp *) interp)->flags |= EXPR_INITIALIZED;
  1385.     for (funcPtr = funcTable; funcPtr->name != NULL;
  1386.         funcPtr++) {
  1387.         Tcl_CreateMathFunc(interp, funcPtr->name, funcPtr->numArgs,
  1388.             funcPtr->argTypes, funcPtr->proc, funcPtr->clientData);
  1389.     }
  1390.     }
  1391.  
  1392.     info.originalExpr = string;
  1393.     info.expr = string;
  1394.     valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace;
  1395.     valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1;
  1396.     valuePtr->pv.expandProc = TclExpandParseValue;
  1397.     valuePtr->pv.clientData = (ClientData) NULL;
  1398.  
  1399.     result = ExprGetValue(interp, &info, -1, valuePtr);
  1400.     if (result != TCL_OK) {
  1401.     return result;
  1402.     }
  1403.     if (info.token != END) {
  1404.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1405.         string, "\"", (char *) NULL);
  1406.     return TCL_ERROR;
  1407.     }
  1408.     if ((valuePtr->type == TYPE_DOUBLE) && (IS_NAN(valuePtr->doubleValue)
  1409.         || IS_INF(valuePtr->doubleValue))) {
  1410.     /*
  1411.      * IEEE floating-point error.
  1412.      */
  1413.  
  1414.     ExprFloatError(interp, valuePtr->doubleValue);
  1415.     return TCL_ERROR;
  1416.     }
  1417.     return TCL_OK;
  1418. }
  1419.  
  1420. /*
  1421.  *--------------------------------------------------------------
  1422.  *
  1423.  * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
  1424.  *
  1425.  *    Procedures to evaluate an expression and return its value
  1426.  *    in a particular form.
  1427.  *
  1428.  * Results:
  1429.  *    Each of the procedures below returns a standard Tcl result.
  1430.  *    If an error occurs then an error message is left in
  1431.  *    interp->result.  Otherwise the value of the expression,
  1432.  *    in the appropriate form, is stored at *resultPtr.  If
  1433.  *    the expression had a result that was incompatible with the
  1434.  *    desired form then an error is returned.
  1435.  *
  1436.  * Side effects:
  1437.  *    None.
  1438.  *
  1439.  *--------------------------------------------------------------
  1440.  */
  1441.  
  1442. int
  1443. Tcl_ExprLong(interp, string, ptr)
  1444.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1445.                      * expression. */
  1446.     char *string;            /* Expression to evaluate. */
  1447.     long *ptr;                /* Where to store result. */
  1448. {
  1449.     Value value;
  1450.     int result;
  1451.  
  1452.     result = ExprTopLevel(interp, string, &value);
  1453.     if (result == TCL_OK) {
  1454.     if (value.type == TYPE_INT) {
  1455.         *ptr = value.intValue;
  1456.     } else if (value.type == TYPE_DOUBLE) {
  1457.         *ptr = value.doubleValue;
  1458.     } else {
  1459.         interp->result = "expression didn't have numeric value";
  1460.         result = TCL_ERROR;
  1461.     }
  1462.     }
  1463.     if (value.pv.buffer != value.staticSpace) {
  1464.     ckfree(value.pv.buffer);
  1465.     }
  1466.     return result;
  1467. }
  1468.  
  1469. int
  1470. Tcl_ExprDouble(interp, string, ptr)
  1471.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1472.                      * expression. */
  1473.     char *string;            /* Expression to evaluate. */
  1474.     double *ptr;            /* Where to store result. */
  1475. {
  1476.     Value value;
  1477.     int result;
  1478.  
  1479.     result = ExprTopLevel(interp, string, &value);
  1480.     if (result == TCL_OK) {
  1481.     if (value.type == TYPE_INT) {
  1482.         *ptr = value.intValue;
  1483.     } else if (value.type == TYPE_DOUBLE) {
  1484.         *ptr = value.doubleValue;
  1485.     } else {
  1486.         interp->result = "expression didn't have numeric value";
  1487.         result = TCL_ERROR;
  1488.     }
  1489.     }
  1490.     if (value.pv.buffer != value.staticSpace) {
  1491.     ckfree(value.pv.buffer);
  1492.     }
  1493.     return result;
  1494. }
  1495.  
  1496. int
  1497. Tcl_ExprBoolean(interp, string, ptr)
  1498.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1499.                      * expression. */
  1500.     char *string;            /* Expression to evaluate. */
  1501.     int *ptr;                /* Where to store 0/1 result. */
  1502. {
  1503.     Value value;
  1504.     int result;
  1505.  
  1506.     result = ExprTopLevel(interp, string, &value);
  1507.     if (result == TCL_OK) {
  1508.     if (value.type == TYPE_INT) {
  1509.         *ptr = value.intValue != 0;
  1510.     } else if (value.type == TYPE_DOUBLE) {
  1511.         *ptr = value.doubleValue != 0.0;
  1512.     } else {
  1513.         result = Tcl_GetBoolean(interp, value.pv.buffer, ptr);
  1514.     }
  1515.     }
  1516.     if (value.pv.buffer != value.staticSpace) {
  1517.     ckfree(value.pv.buffer);
  1518.     }
  1519.     return result;
  1520. }
  1521.  
  1522. /*
  1523.  *--------------------------------------------------------------
  1524.  *
  1525.  * Tcl_ExprString --
  1526.  *
  1527.  *    Evaluate an expression and return its value in string form.
  1528.  *
  1529.  * Results:
  1530.  *    A standard Tcl result.  If the result is TCL_OK, then the
  1531.  *    interpreter's result is set to the string value of the
  1532.  *    expression.  If the result is TCL_OK, then interp->result
  1533.  *    contains an error message.
  1534.  *
  1535.  * Side effects:
  1536.  *    None.
  1537.  *
  1538.  *--------------------------------------------------------------
  1539.  */
  1540.  
  1541. int
  1542. Tcl_ExprString(interp, string)
  1543.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1544.                      * expression. */
  1545.     char *string;            /* Expression to evaluate. */
  1546. {
  1547.     Value value;
  1548.     int result;
  1549.  
  1550.     result = ExprTopLevel(interp, string, &value);
  1551.     if (result == TCL_OK) {
  1552.     if (value.type == TYPE_INT) {
  1553.         sprintf(interp->result, "%ld", value.intValue);
  1554.     } else if (value.type == TYPE_DOUBLE) {
  1555.         Tcl_PrintDouble(interp, value.doubleValue, interp->result);
  1556.     } else {
  1557.         if (value.pv.buffer != value.staticSpace) {
  1558.         interp->result = value.pv.buffer;
  1559.         interp->freeProc = (Tcl_FreeProc *) free;
  1560.         value.pv.buffer = value.staticSpace;
  1561.         } else {
  1562.         Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE);
  1563.         }
  1564.     }
  1565.     }
  1566.     if (value.pv.buffer != value.staticSpace) {
  1567.     ckfree(value.pv.buffer);
  1568.     }
  1569.     return result;
  1570. }
  1571.  
  1572. /*
  1573.  *----------------------------------------------------------------------
  1574.  *
  1575.  * Tcl_CreateMathFunc --
  1576.  *
  1577.  *    Creates a new math function for expressions in a given
  1578.  *    interpreter.
  1579.  *
  1580.  * Results:
  1581.  *    None.
  1582.  *
  1583.  * Side effects:
  1584.  *    The function defined by "name" is created;  if such a function
  1585.  *    already existed then its definition is overriden.
  1586.  *
  1587.  *----------------------------------------------------------------------
  1588.  */
  1589.  
  1590. void
  1591. Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
  1592.     Tcl_Interp *interp;            /* Interpreter in which function is
  1593.                      * to be available. */
  1594.     char *name;                /* Name of function (e.g. "sin"). */
  1595.     int numArgs;            /* Nnumber of arguments required by
  1596.                      * function. */
  1597.     Tcl_ValueType *argTypes;        /* Array of types acceptable for
  1598.                      * each argument. */
  1599.     Tcl_MathProc *proc;            /* Procedure that implements the
  1600.                      * math function. */
  1601.     ClientData clientData;        /* Additional value to pass to the
  1602.                      * function. */
  1603. {
  1604.     Interp *iPtr = (Interp *) interp;
  1605.     Tcl_HashEntry *hPtr;
  1606.     MathFunc *mathFuncPtr;
  1607.     int new, i;
  1608.  
  1609.     hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
  1610.     if (new) {
  1611.     Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
  1612.     }
  1613.     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
  1614.     if (numArgs > MAX_MATH_ARGS) {
  1615.     numArgs = MAX_MATH_ARGS;
  1616.     }
  1617.     mathFuncPtr->numArgs = numArgs;
  1618.     for (i = 0; i < numArgs; i++) {
  1619.     mathFuncPtr->argTypes[i] = argTypes[i];
  1620.     }
  1621.     mathFuncPtr->proc = proc;
  1622.     mathFuncPtr->clientData = clientData;
  1623. }
  1624.  
  1625. /*
  1626.  *----------------------------------------------------------------------
  1627.  *
  1628.  * ExprMathFunc --
  1629.  *
  1630.  *    This procedure is invoked to parse a math function from an
  1631.  *    expression string, carry out the function, and return the
  1632.  *    value computed.
  1633.  *
  1634.  * Results:
  1635.  *    TCL_OK is returned if all went well and the function's value
  1636.  *    was computed successfully.  If an error occurred, TCL_ERROR
  1637.  *    is returned and an error message is left in interp->result.
  1638.  *    After a successful return infoPtr has been updated to refer
  1639.  *    to the character just after the function call, the token is
  1640.  *    set to VALUE, and the value is stored in valuePtr.
  1641.  *
  1642.  * Side effects:
  1643.  *    Embedded commands could have arbitrary side-effects.
  1644.  *
  1645.  *----------------------------------------------------------------------
  1646.  */
  1647.  
  1648. static int
  1649. ExprMathFunc(interp, infoPtr, valuePtr)
  1650.     Tcl_Interp *interp;            /* Interpreter to use for error
  1651.                      * reporting. */
  1652.     register ExprInfo *infoPtr;        /* Describes the state of the parse.
  1653.                      * infoPtr->expr must point to the
  1654.                      * first character of the function's
  1655.                      * name. */
  1656.     register Value *valuePtr;        /* Where to store value, if that is
  1657.                      * what's parsed from string.  Caller
  1658.                      * must have initialized pv field
  1659.                      * correctly. */
  1660. {
  1661.     Interp *iPtr = (Interp *) interp;
  1662.     MathFunc *mathFuncPtr;        /* Info about math function. */
  1663.     Tcl_Value args[MAX_MATH_ARGS];    /* Arguments for function call. */
  1664.     Tcl_Value funcResult;        /* Result of function call. */
  1665.     Tcl_HashEntry *hPtr;
  1666.     char *p, *funcName;
  1667.     int i, savedChar, result;
  1668.  
  1669.     /*
  1670.      * Find the end of the math function's name and lookup the MathFunc
  1671.      * record for the function.
  1672.      */
  1673.  
  1674.     p = funcName = infoPtr->expr;
  1675.     while (isalnum(UCHAR(*p)) || (*p == '_')) {
  1676.     p++;
  1677.     }
  1678.     infoPtr->expr = p;
  1679.     result = ExprLex(interp, infoPtr, valuePtr);
  1680.     if (infoPtr->token != OPEN_PAREN) {
  1681.     goto syntaxError;
  1682.     }
  1683.     savedChar = *p;
  1684.     *p = 0;
  1685.     hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
  1686.     if (hPtr == NULL) {
  1687.     Tcl_AppendResult(interp, "unknown math function \"", funcName,
  1688.         "\"", (char *) NULL);
  1689.     *p = savedChar;
  1690.     return TCL_ERROR;
  1691.     }
  1692.     *p = savedChar;
  1693.     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
  1694.  
  1695.     /*
  1696.      * Scan off the arguments for the function, if there are any.
  1697.      */
  1698.  
  1699.     if (mathFuncPtr->numArgs == 0) {
  1700.     result = ExprLex(interp, infoPtr, valuePtr);
  1701.     if (infoPtr->token != CLOSE_PAREN) {
  1702.         goto syntaxError;
  1703.     }
  1704.     } else {
  1705.     for (i = 0; ; i++) {
  1706.         valuePtr->pv.next = valuePtr->pv.buffer;
  1707.         result = ExprGetValue(interp, infoPtr, -1, valuePtr);
  1708.         if (result != TCL_OK) {
  1709.         return result;
  1710.         }
  1711.         if (valuePtr->type == TYPE_STRING) {
  1712.         interp->result =
  1713.             "argument to math function didn't have numeric value";
  1714.         return TCL_ERROR;
  1715.         }
  1716.     
  1717.         /*
  1718.          * Copy the value to the argument record, converting it if
  1719.          * necessary.
  1720.          */
  1721.     
  1722.         if (valuePtr->type == TYPE_INT) {
  1723.         if (mathFuncPtr->argTypes[i] == TCL_DOUBLE) {
  1724.             args[i].type = TCL_DOUBLE;
  1725.             args[i].doubleValue = valuePtr->intValue;
  1726.         } else {
  1727.             args[i].type = TCL_INT;
  1728.             args[i].intValue = valuePtr->intValue;
  1729.         }
  1730.         } else {
  1731.         if (mathFuncPtr->argTypes[i] == TCL_INT) {
  1732.             args[i].type = TCL_INT;
  1733.             args[i].intValue = valuePtr->doubleValue;
  1734.         } else {
  1735.             args[i].type = TCL_DOUBLE;
  1736.             args[i].doubleValue = valuePtr->doubleValue;
  1737.         }
  1738.         }
  1739.     
  1740.         /*
  1741.          * Check for a comma separator between arguments or a close-paren
  1742.          * to end the argument list.
  1743.          */
  1744.     
  1745.         if (i == (mathFuncPtr->numArgs-1)) {
  1746.         if (infoPtr->token == CLOSE_PAREN) {
  1747.             break;
  1748.         }
  1749.         if (infoPtr->token == COMMA) {
  1750.             interp->result = "too many arguments for math function";
  1751.             return TCL_ERROR;
  1752.         } else {
  1753.             goto syntaxError;
  1754.         }
  1755.         }
  1756.         if (infoPtr->token != COMMA) {
  1757.         if (infoPtr->token == CLOSE_PAREN) {
  1758.             interp->result = "too few arguments for math function";
  1759.             return TCL_ERROR;
  1760.         } else {
  1761.             goto syntaxError;
  1762.         }
  1763.         }
  1764.     }
  1765.     }
  1766.  
  1767.     /*
  1768.      * Invoke the function and copy its result back into valuePtr.
  1769.      */
  1770.  
  1771.     tcl_MathInProgress++;
  1772.     result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
  1773.         &funcResult);
  1774.     tcl_MathInProgress--;
  1775.     if (result != TCL_OK) {
  1776.     return result;
  1777.     }
  1778.     if (funcResult.type == TCL_INT) {
  1779.     valuePtr->type = TYPE_INT;
  1780.     valuePtr->intValue = funcResult.intValue;
  1781.     } else {
  1782.     valuePtr->type = TYPE_DOUBLE;
  1783.     valuePtr->doubleValue = funcResult.doubleValue;
  1784.     }
  1785.     infoPtr->token = VALUE;
  1786.     return TCL_OK;
  1787.  
  1788.     syntaxError:
  1789.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1790.         infoPtr->originalExpr, "\"", (char *) NULL);
  1791.     return TCL_ERROR;
  1792. }
  1793.  
  1794. /*
  1795.  *----------------------------------------------------------------------
  1796.  *
  1797.  * ExprFloatError --
  1798.  *
  1799.  *    This procedure is called when an error occurs during a
  1800.  *    floating-point operation.  It reads errno and sets
  1801.  *    interp->result accordingly.
  1802.  *
  1803.  * Results:
  1804.  *    Interp->result is set to hold an error message.
  1805.  *
  1806.  * Side effects:
  1807.  *    None.
  1808.  *
  1809.  *----------------------------------------------------------------------
  1810.  */
  1811.  
  1812. static void
  1813. ExprFloatError(interp, value)
  1814.     Tcl_Interp *interp;        /* Where to store error message. */
  1815.     double value;        /* Value returned after error;  used to
  1816.                  * distinguish underflows from overflows. */
  1817. {
  1818.     char buf[20];
  1819.  
  1820.     if ((errno == EDOM) || (value != value)) {
  1821.     interp->result = "domain error: argument not in valid range";
  1822.     Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", interp->result,
  1823.         (char *) NULL);
  1824.     } else if ((errno == ERANGE) || IS_INF(value)) {
  1825.     if (value == 0.0) {
  1826.         interp->result = "floating-point value too small to represent";
  1827.         Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", interp->result,
  1828.             (char *) NULL);
  1829.     } else {
  1830.         interp->result = "floating-point value too large to represent";
  1831.         Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", interp->result,
  1832.             (char *) NULL);
  1833.     }
  1834.     } else {
  1835.     sprintf(buf, "%d", errno);
  1836.     Tcl_AppendResult(interp, "unknown floating-point error, ",
  1837.         "errno = ", buf, (char *) NULL);
  1838.     Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", interp->result,
  1839.         (char *) NULL);
  1840.     }
  1841. }
  1842.  
  1843. /*
  1844.  *----------------------------------------------------------------------
  1845.  *
  1846.  * Math Functions --
  1847.  *
  1848.  *    This page contains the procedures that implement all of the
  1849.  *    built-in math functions for expressions.
  1850.  *
  1851.  * Results:
  1852.  *    Each procedure returns TCL_OK if it succeeds and places result
  1853.  *    information at *resultPtr.  If it fails it returns TCL_ERROR
  1854.  *    and leaves an error message in interp->result.
  1855.  *
  1856.  * Side effects:
  1857.  *    None.
  1858.  *
  1859.  *----------------------------------------------------------------------
  1860.  */
  1861.  
  1862. static int
  1863. ExprUnaryFunc(clientData, interp, args, resultPtr)
  1864.     ClientData clientData;        /* Contains address of procedure that
  1865.                      * takes one double argument and
  1866.                      * returns a double result. */
  1867.     Tcl_Interp *interp;
  1868.     Tcl_Value *args;
  1869.     Tcl_Value *resultPtr;
  1870. {
  1871.     double (*func)() = (double (*)()) clientData;
  1872.  
  1873.     errno = 0;
  1874.     resultPtr->type = TCL_DOUBLE;
  1875.     resultPtr->doubleValue = (*func)(args[0].doubleValue);
  1876.     if (errno != 0) {
  1877.     ExprFloatError(interp, resultPtr->doubleValue);
  1878.     return TCL_ERROR;
  1879.     }
  1880.     return TCL_OK;
  1881. }
  1882.  
  1883. static int
  1884. ExprBinaryFunc(clientData, interp, args, resultPtr)
  1885.     ClientData clientData;        /* Contains address of procedure that
  1886.                      * takes two double arguments and
  1887.                      * returns a double result. */
  1888.     Tcl_Interp *interp;
  1889.     Tcl_Value *args;
  1890.     Tcl_Value *resultPtr;
  1891. {
  1892.     double (*func)() = (double (*)()) clientData;
  1893.  
  1894.     errno = 0;
  1895.     resultPtr->type = TCL_DOUBLE;
  1896.     resultPtr->doubleValue = (*func)(args[0].doubleValue, args[1].doubleValue);
  1897.     if (errno != 0) {
  1898.     ExprFloatError(interp, resultPtr->doubleValue);
  1899.     return TCL_ERROR;
  1900.     }
  1901.     return TCL_OK;
  1902. }
  1903.  
  1904.     /* ARGSUSED */
  1905. static int
  1906. ExprAbsFunc(clientData, interp, args, resultPtr)
  1907.     ClientData clientData;
  1908.     Tcl_Interp *interp;
  1909.     Tcl_Value *args;
  1910.     Tcl_Value *resultPtr;
  1911. {
  1912.     resultPtr->type = TCL_DOUBLE;
  1913.     if (args[0].type == TCL_DOUBLE) {
  1914.     resultPtr->type = TCL_DOUBLE;
  1915.     if (args[0].doubleValue < 0) {
  1916.         resultPtr->doubleValue = -args[0].doubleValue;
  1917.     } else {
  1918.         resultPtr->doubleValue = args[0].doubleValue;
  1919.     }
  1920.     } else {
  1921.     resultPtr->type = TCL_INT;
  1922.     if (args[0].intValue < 0) {
  1923.         resultPtr->intValue = -args[0].intValue;
  1924.         if (resultPtr->intValue < 0) {
  1925.         interp->result = "integer value too large to represent";
  1926.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result,
  1927.             (char *) NULL);
  1928.         return TCL_ERROR;
  1929.         }
  1930.     } else {
  1931.         resultPtr->intValue = args[0].intValue;
  1932.     }
  1933.     }
  1934.     return TCL_OK;
  1935. }
  1936.  
  1937.     /* ARGSUSED */
  1938. static int
  1939. ExprDoubleFunc(clientData, interp, args, resultPtr)
  1940.     ClientData clientData;
  1941.     Tcl_Interp *interp;
  1942.     Tcl_Value *args;
  1943.     Tcl_Value *resultPtr;
  1944. {
  1945.     resultPtr->type = TCL_DOUBLE;
  1946.     if (args[0].type == TCL_DOUBLE) {
  1947.     resultPtr->doubleValue = args[0].doubleValue;
  1948.     } else {
  1949.     resultPtr->doubleValue = args[0].intValue;
  1950.     }
  1951.     return TCL_OK;
  1952. }
  1953.  
  1954.     /* ARGSUSED */
  1955. static int
  1956. ExprIntFunc(clientData, interp, args, resultPtr)
  1957.     ClientData clientData;
  1958.     Tcl_Interp *interp;
  1959.     Tcl_Value *args;
  1960.     Tcl_Value *resultPtr;
  1961. {
  1962.     resultPtr->type = TCL_INT;
  1963.     if (args[0].type == TCL_INT) {
  1964.     resultPtr->intValue = args[0].intValue;
  1965.     } else {
  1966.     if (args[0].doubleValue < 0) {
  1967.         if (args[0].doubleValue < (double) (long) LONG_MIN) {
  1968.         tooLarge:
  1969.         interp->result = "integer value too large to represent";
  1970.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
  1971.             interp->result, (char *) NULL);
  1972.         return TCL_ERROR;
  1973.         }
  1974.     } else {
  1975.         if (args[0].doubleValue > (double) LONG_MAX) {
  1976.         goto tooLarge;
  1977.         }
  1978.     }
  1979.     resultPtr->intValue = args[0].doubleValue;
  1980.     }
  1981.     return TCL_OK;
  1982. }
  1983.  
  1984.     /* ARGSUSED */
  1985. static int
  1986. ExprRoundFunc(clientData, interp, args, resultPtr)
  1987.     ClientData clientData;
  1988.     Tcl_Interp *interp;
  1989.     Tcl_Value *args;
  1990.     Tcl_Value *resultPtr;
  1991. {
  1992.     resultPtr->type = TCL_INT;
  1993.     if (args[0].type == TCL_INT) {
  1994.     resultPtr->intValue = args[0].intValue;
  1995.     } else {
  1996.     if (args[0].doubleValue < 0) {
  1997.         if (args[0].doubleValue <= (((double) (long) LONG_MIN) - 0.5)) {
  1998.         tooLarge:
  1999.         interp->result = "integer value too large to represent";
  2000.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
  2001.             interp->result, (char *) NULL);
  2002.         return TCL_ERROR;
  2003.         }
  2004.         resultPtr->intValue = (args[0].doubleValue - 0.5);
  2005.     } else {
  2006.         if (args[0].doubleValue >= (((double) LONG_MAX + 0.5))) {
  2007.         goto tooLarge;
  2008.         }
  2009.         resultPtr->intValue = (args[0].doubleValue + 0.5);
  2010.     }
  2011.     }
  2012.     return TCL_OK;
  2013. }
  2014.